home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 9 / Night Owl CD-ROM (NOPV9) (Night Owl Publisher) (1993).ISO / 012a / lib194.zip / SCREEN.PRG < prev    next >
Text File  |  1993-02-05  |  55KB  |  1,350 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: SCREEN.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 02/05/1993
  5. *-- Notes.....: A few routines not left in PROC.PRG, these are not used as much
  6. *--             by my own systems. See the file: README.TXT for details on how
  7. *--             to use this library file.
  8. *-------------------------------------------------------------------------------
  9.  
  10. FUNCTION Radio
  11. *-------------------------------------------------------------------------------
  12. *-- Programmer..: Ed Lafferty (CIS: 76150,3302)
  13. *-- Date........: 06/08/1992
  14. *-- Notes.......: Routine to create and size a popup with radio buttons
  15. *--               for choosing only one of up to four options.  Pressing
  16. *--               the <Space Bar> on an option turns it on or off.
  17. *--               Pressing <Enter> chooses the selected option and leaves
  18. *--               the routine.
  19. *-- Written for.: dBase IV, 1.1
  20. *-- Rev. History: 02/25/1992 - original procedure.
  21. *--               02/27/1992 -- Ken Mayer -- added option for color, but had
  22. *--               to take number of choices back to 4 to do so. Minor 
  23. *--               alterations performed to add color choice ... and cleaning
  24. *--               up after self ... (original cleared the screen first ...
  25. *--               this version saves screen, restores back to it ...) Oh yeah,
  26. *--               I turned it into a function, rather than a procedure, as well.
  27. *-- Calls.......: CENTER                Procedure in PROC.PRG
  28. *--               SHADOW                Procedure in PROC.PRG
  29. *--               COLORBRK()            Function in PROC.PRG
  30. *-- Called by...: Any
  31. *-- Usage.......: Radio(<nULRow>,<nULCol>,<nChoice>,"<cTxt1>","<cTxt2>",;
  32. *--                        "<cTxt3>","<cTxt4>","<cTitle>","<cColor>")
  33. *-- Example.....: cPort = Radio(8,15,1,"LPT1","LPT2","LPT3","",;
  34. *--                             "Choose a printer port","rg+/gb,n/w,rg+/gb")
  35. *-- Returns.....: number of chosen button in nChoice
  36. *-- Parameters..: nUlrow  = upper left row of popup
  37. *--               nUlcol  = upper left column of popup
  38. *--               nChoice = default chosen button
  39. *--               cTxt1   = Text for 1st button
  40. *--               cTxt2   =  "    "  2nd   "
  41. *--               cTxt3   =  "    "  3rd   "
  42. *--               cTxt4   =  "    "  4th   "
  43. *--               cTitle  = Text for the box title
  44. *--               cColor  = Color string (i.e., "RG+/GB,N/W,RG+/GB")
  45. *-------------------------------------------------------------------------------
  46.  
  47.     parameters nUlrow, nUlcol, nChoice, cTxt1, cTxt2, cTxt3, cTxt4, ;
  48.                     cTitle, cColor
  49.     private nHeight, nKey, nCnt, nWidth, cStr, cTxt0, cMidCol, cFirstCol,;
  50.                    cCursor
  51.     
  52.     cCursor = set("CURSOR")
  53.     store cTitle to cTxt0
  54.     save screen to sRadio
  55.     store 0 to nHeight, nKey, nCnt, nWidth
  56.     store nChoice to nOrig  && in case user presses <Esc> to exit ...
  57.     
  58.     *-- deal with these colors in displaying some stuff ...
  59.     cMidCol = colorbrk(cColor,2)
  60.     *-- First color (for message) is easier ...
  61.     cFirstCol = colorbrk(cColor,1)
  62.     
  63.     *-- Determine height and width of popup
  64.     do case
  65.         case len(cTxt4) > 0
  66.            nHeight = 4
  67.         case len(cTxt3) > 0
  68.            nHeight = 3
  69.         case len(cTxt2) > 0
  70.            nHeight = 2
  71.         otherwise
  72.            nHeight = 1
  73.     endcase
  74.     
  75.     do while nCnt <=nHeight
  76.        store "cTxt"+str(nCnt,1) to cStr
  77.        if len(&cstr) > nWidth
  78.           nWidth = len(&cStr)
  79.        endif
  80.        nCnt = nCnt + 1
  81.     enddo
  82.     
  83.     *-- create popup
  84.     define window wRadio from nUlRow,nUlCol to nUlRow+nHeight+3,nUlCol+nWidth+9;
  85.             double color &cColor
  86.     do center with 23,80,"&cFirstCol","Press "+chr(24)+chr(25)+;
  87.                                     ", <Space> to select/de-select, <Enter> to quit"
  88.     activate screen
  89.     do shadow with nULRow, nULCol, nULRow+nHeight+3, nULCol+nWidth+9
  90.     activate window wRadio
  91.     
  92.     *-- display screen
  93.     store 1 to nCnt
  94.     do center with 0, nWidth+8, "", cTitle
  95.     do while nCnt <= nHeight
  96.        store "cTxt"+str(nCnt,1) to cStr
  97.        @ nCnt+1, 2 SAY "[ ]" color &cMidCol
  98.         @ nCnt+1, 6 say &cStr
  99.        nCnt = nCnt + 1
  100.     enddo
  101.     
  102.     *-- prepare for and get nChoice
  103.     if nChoice > 0
  104.        store nChoice to nCnt
  105.         @nCnt+1,3 say "■" color &cMidCol
  106.     else
  107.        store 1 to nCnt
  108.     endif
  109.     store .F. to ldone
  110.     
  111.     *-- this loop processes user input ... 
  112.     do while .not. ldone
  113.         @ nCnt+1,3 say "" color &cMidCol
  114.         nkey = inkey(0)
  115.         do case
  116.         case nkey = 27                   && Press Esc to exit
  117.            store nOrig to nChoice        && Leave at "default"
  118.            store .T. to ldone
  119.         case nkey = 13
  120.            store .T. to ldone
  121.         case nkey = 32                   && Press Enter or Space
  122.               set cursor off
  123.               if nChoice = nCnt
  124.                  @ nCnt+1,3 say " " color &cMidCol
  125.                  store 0 to nChoice
  126.               else
  127.                  @ nChoice+1,3 say " " color &cMidCol
  128.                  @ nCnt+1,3 say "■" color &cMidCol
  129.                  store nCnt to nChoice
  130.               endif
  131.               set cursor on
  132.         case nkey = 5                    && Press up arrow
  133.            if nCnt > 1
  134.               nCnt = nCnt - 1
  135.            else
  136.               nCnt = nHeight
  137.            endif
  138.         case nkey = 24                   && Press down arrow
  139.            if nCnt < nHeight
  140.               nCnt = nCnt + 1
  141.            else
  142.               nCnt = 1
  143.            endif
  144.         endcase
  145.     enddo
  146.     
  147.     *-- cleanup
  148.     deact window wRadio
  149.     release window wRadio
  150.     restore screen from sRadio
  151.     release screen sRadio
  152.     set message to
  153.     set cursor &cCursor
  154.     
  155. RETURN nChoice
  156. *-- EoF: Radio()
  157.  
  158. PROCEDURE CheckBox
  159. *-------------------------------------------------------------------------------
  160. *-- Programmer..: Ed Lafferty (CIS: 76150,3302)
  161. *-- Date........: 02/28/1992
  162. *-- Notes.......: Routine to create and size a popup with check boxes
  163. *--               for choosing any of a number (up to five) options.  Pressing
  164. *--               the <Space Bar> on an option turns it on or off.
  165. *--               Pressing <Enter> chooses the selected option and leaves
  166. *--               the routine. You must use a data structure with logical
  167. *--               fields, or memvars that are logical for this. Either way,
  168. *--               even if you don't use five logical fields/memvars, you must
  169. *--               pass a field/memvar to the procedure -- see Example below 
  170. *--               (the logicals -- lCHK1, lCHK2, etc.-- must be fields or
  171. *--               memvars due to a limitation in parameter passing in dBASE IV.)
  172. *-- Written for.: dBase IV, Version 1.1
  173. *-- Rev. History: 02/25/1992 - original procedure.
  174. *--               02/28/1992 -- Ken Mayer -- modified to allow passing cColor,
  175. *--               and a little cleanup of code and such. Minor changes.
  176. *-- Calls.......: CENTER               Procedure in PROC.PRG
  177. *--               SHADOW               Procedure in PROC.PRG
  178. *--               COLORBRK()           Function in PROC.PRG
  179. *-- Called by...: Any
  180. *-- Usage.......: do checkbox with <nULCol>,<nULRow>,<lchk1>,<lchk2>,<lchk3>,;
  181. *--                          <lchk4>,"<cTxt1>","<cTxt2>","<cTxt2>",;
  182. *--                          "<cTxt3>","<cTxt4>","<cTxt0>","<cColor>"
  183. *-- Example.....: do Checkbox with 8, 15, lchk1, lchk2, lchk3, lchk4,;
  184. *--                    "LPT1", "LPT2", "LPT3","","Choose a printer port",;
  185. *--                    "rg+/gb,w+/n,rg+/gb"
  186. *-- Returns.....: .T. for selected items, .F. for non-selected items --
  187. *--               this routine changes the value of the logical fields passed
  188. *--               to it.
  189. *-- Parameters..: nULRow = upper left row of popup
  190. *--               nULCol = upper left column of popup
  191. *--               lChkn  = default value of box 'n' -- MUST BE FIELDS/MEMVARS
  192. *--               cTxt1  = Text for 1st box
  193. *--               cTxt2  =  "    "  2nd   "
  194. *--               cTxt3  =  "    "  3rd   "
  195. *--               cTxt4  =  "    "  4th   "
  196. *--               cTxt0  = Text for the box title
  197. *--               cColor = Colors to be used in window ...
  198. *-------------------------------------------------------------------------------
  199.  
  200.     parameters nUlrow, nUlcol, lChk1, lChk2, lChk3, lChk4, ;
  201.                  cTxt1, cTxt2, cTxt3, cTxt4, cTxt0, cColor
  202.     private nHeight, nKey, nCnt, nWidth, lOrig1, lOrig2, lOrig3, lOrig4,;
  203.               cMidCol, cFirstCol, cCursor 
  204.     
  205.     *-- setup ...
  206.     cCursor = set("CURSOR")
  207.     save screen to sCheck
  208.     store 0 to nHeight, nKey, nCnt, nWidth
  209.     *-- save original settings, in case <Esc> gets pressed below ...
  210.     store lChk1 to lOrig1
  211.     store lChk2 to lOrig2
  212.     store lChk3 to lOrig3
  213.     store lChk4 to lOrig4
  214.     *-- deal with some colors ...
  215.     cMidCol = colorbrk(cColor,2)
  216.     cFirstCol = colorbrk(cColor,1)
  217.     
  218.     *-- Determine height and width of popup
  219.     *-- Determine height
  220.     do case
  221.     case len(cTxt4) > 0
  222.        nHeight = 4
  223.     case len(cTxt3) > 0
  224.        nHeight = 3
  225.     case len(cTxt2) > 0
  226.        nHeight = 2
  227.     case len(cTxt1) > 0
  228.        nHeight = 1
  229.     endcase
  230.     
  231.     *-- Determine width
  232.     do while nCnt <=nHeight
  233.        store "cTxt"+str(nCnt,1) to cStr
  234.        if len(&cstr) > nWidth
  235.           nWidth = len(&cStr)
  236.        endif
  237.        nCnt = nCnt + 1
  238.     enddo
  239.     
  240.     *-- create popup
  241.     define window wCheck from nUlrow, nUlcol to nUlrow+nHeight+3, nUlcol+nWidth+8;
  242.         double color &cColor
  243.     do center with 23,80,"&cFirstCol","Press "+chr(24)+chr(25)+;
  244.         ", <Space> to select/de-select, <Enter> to quit"
  245.     activate screen
  246.     do shadow with nULRow,nULCol,nULRow+nHeight+3,nULCol+nWidth+8
  247.     activate window wCheck
  248.     store 1 to nCnt
  249.     do center with 0, nWidth+8, "", cTxt0
  250.     
  251.     *-- paint screen
  252.     do while nCnt <= nHeight
  253.        store "cTxt"+str(nCnt,1) to cStr
  254.        store "lChk"+str(nCnt,1) to cChk
  255.        @ nCnt+1, 2 SAY "[ ]" color &cMidCol
  256.         @ nCnt+1, 6 say &cStr
  257.        @ nCnt+1, 3 SAY IIF(&cChk,"X"," ") color &cMidCol
  258.        nCnt = nCnt + 1
  259.     enddo
  260.         
  261.     *-- prepare for and get nChoice
  262.     store 1 to nCnt
  263.     store .F. to ldone
  264.     do while .not. ldone
  265.         store "lChk"+str(nCnt,1) to cChk
  266.         @ nCnt+1,3 say "" color &cMidCol
  267.         nkey = inkey(0)
  268.         do case
  269.             case nkey = 27                   && Press Esc to exit
  270.                store lorig1 to lChk1         && Therefore, restore original
  271.                store lOrig2 to lChk2         && values to lChk<n>'s
  272.                store lOrig3 to lChk3
  273.                store lOrig4 to lChk4
  274.                store .T. to ldone
  275.             case nkey = 13                   && Press Enter when finished
  276.                store .T. to ldone
  277.             case nkey = 32                   && Press Space
  278.                   set cursor off
  279.                   if &cChk                          && Box was already selected,
  280.                      @ nCnt+1,3 say " " color &cMidCol   && so now de-select it
  281.                      store .F. to &cChk
  282.                   else                              && Box was not already selected,
  283.                      @ nCnt+1,3 say "X" color &cMidCol   && so now select it
  284.                      store .T. to &cChk
  285.                   endif
  286.                   set cursor on
  287.             case nkey = 5                    && Press up arrow
  288.                if nCnt > 1
  289.                   nCnt = nCnt - 1
  290.                else
  291.                   nCnt = nHeight
  292.                endif
  293.             case nkey = 24                   && Press down arrow
  294.                if nCnt < nHeight
  295.                   nCnt = nCnt + 1
  296.                else
  297.                   nCnt = 1
  298.                endif
  299.         endcase
  300.     enddo
  301.     
  302.     *-- Cleanup
  303.     release window wCheck
  304.     restore screen from sCheck
  305.     release screen sCheck
  306.     set message to
  307.     set cursor &cCursor
  308.     
  309. RETURN
  310. *-- EoP: ChkBox
  311.  
  312. FUNCTION MenuPad
  313. *-------------------------------------------------------------------------------
  314. *-- Programmer..: Douglas P. Saine (CIS: 74660,3574)
  315. *-- Date........: 02/11/1992
  316. *-- Notes.......: Used to create menu prompts of an even length. It works
  317. *--               on any prompt - menu pads or popups.
  318. *-- Written for.: dBASE IV, 1.1
  319. *-- Rev. History: 02/07/1992 - original function.
  320. *--               02/11/1992 -- Ken Mayer -- modified to truncate <cChoice>
  321. *--                 if it's longer than <nLength>.
  322. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  323. *-- Called by...: Any
  324. *-- Usage.......: MenuPad("<cChoice>",<nLength>)
  325. *-- Example.....: Define pad pPad1 of mMain;
  326. *--                      prompt MenuPad("Menu Choice1",25) at 2,5
  327. *-- Returns.....: <cChoice> padded with spaces (or truncated, if necessary)
  328. *--               to <nLength>.
  329. *-- Parameters..: cChoice = Menu-Pad/Popup-Bar Prompt description
  330. *--               nLength = Length of pad/bar ...
  331. *-------------------------------------------------------------------------------
  332.  
  333.     parameters cChoice, nLength
  334.     private cReturn
  335.     
  336.     if len(alltrim(cChoice)) > nLength  && is it too long?
  337.         cReturn = left(cChoice,nLength)  && truncate it ...
  338.     else             && otherwise, pad it with spaces to the length required
  339.         cReturn = cChoice + space(nLength-len(alltrim(cChoice)))
  340.     endif
  341.  
  342. RETURN cReturn
  343. *-- EoF: MenuPad()
  344.  
  345. FUNCTION Banner
  346. *-------------------------------------------------------------------------------
  347. *-- Programmer..: Dan Madoni (Borland)
  348. *-- Date........: 09/xx/1991
  349. *-- Notes.......: This will display a left-scrolling message on the screen
  350. *--               within the boundaries specified in the UDF by the user.
  351. *--               It will wait for a keypress and then go away. Taken from
  352. *--               TECHNOTES.
  353. *-- Written for.: dBASE IV, 1.1
  354. *-- Rev. History: None
  355. *-- Usage.......: Banner(<nRow>,<nCol>,<nWidth>,"<cMessage>","<cColor>")
  356. *-- Example.....: ?? Banner(5,30,20,"Love your tie, is it new?","w+/r")
  357. *-- Returns.....: Null ("")
  358. *-- Parameters..: nRow     = Leftmost ROW position of scrolled message
  359. *--               nCol     = Leftmost COL position of scrolled message
  360. *--               nWidth   = Length of displayable area starting at nRow,nCol
  361. *--               cMessage = Message to be scrolled
  362. *--               cColor   = Color of scrolling message
  363. *-------------------------------------------------------------------------------
  364.  
  365.     parameters nRow,nCol,nWidth,cMessage,cColor
  366.     private cCursor,cTalk,cMsg,nCounter,cPause
  367.     
  368.     *-- save some environment essentials
  369.     save screen to sBanner
  370.     cCursor = set("CURSOR")
  371.     cTalk   = set("TALK")
  372.     set cursor off
  373.     set talk off
  374.     
  375.     *-- deal with message
  376.     cMsg = space(nWidth)+cMessage+" "
  377.     nCounter = 0
  378.     
  379.     *-- loop
  380.     do while .t.
  381.         nCounter = nCounter + 1
  382.         if nCounter > len(cMsg)
  383.             nCounter = 1
  384.         endif
  385.         
  386.         *-- user hits any key
  387.         cPause = inkey(.15)
  388.         if cPause # 0
  389.             exit
  390.         endif
  391.         
  392.         *-- display message within scrollable area
  393.         @nRow,nCol say substr(cMsg,nCounter,nWidth) color &cColor
  394.     enddo
  395.     
  396.     *-- restore environment
  397.     restore screen from sBanner
  398.     release screen sBanner
  399.     set cursor &cCursor
  400.     set talk &cTalk
  401.  
  402. RETURN ""
  403. *-- EoF: Banner()
  404.  
  405. FUNCTION SeeMatch
  406. *-------------------------------------------------------------------------------
  407. *-- Programmer..: Dan Madoni (Borland)
  408. *-- Date........: 09/xx/1991
  409. *-- Notes.......: Can be included in format screen to display an instant
  410. *--               lookup match on a particular field. A shadowed box will
  411. *--               appear with the matching value ... Taken from TECHNOTES.
  412. *-- Written for.: dBASE IV, 1.1
  413. *-- Rev. History: 06/12/1992 -- Minor -- added call to RECOLOR
  414. *-- Calls.......: RECOLOR              Procedure in PROC.PRG
  415. *-- Called by...: None
  416. *-- Usage.......: SeeMatch("<cFile>",<cSeekExp>,"<cReturn>",<nULRow>,<nULCol>,;
  417. *--                        <nBRRow>,<nBRCol>,"<cColor>)
  418. *-- Example.....: SeeMatch("TRAVEL",LASTNAME,"TRAVELCODE",2,40,4,60,"w+/r")
  419. *-- Returns.....: .t.
  420. *-- Parameters..: cFile    = Database alias in which lookup will be performed.
  421. *--                          -- this file must already be USEd in some area.
  422. *--               cSeekExp = Expression which will be SEEKed.
  423. *--               cReturn  = Name of field to contain the 'return' value.
  424. *--               nULRow   = Upper Left Row for box
  425. *--               nULCol   = Upper Left Column for box
  426. *--               nBRRow   = Bottom Right Row
  427. *--               nBRCol   = Bottom Right Column
  428. *--               cColor   = Color of box
  429. *-------------------------------------------------------------------------------
  430.     
  431.     parameters cFile,cSeeExp,cReturn,nULRow,nULCol,nBRRow,nBRCol,cColor
  432.     private cRetVal, cAttr, cStartFile
  433.     
  434.     *-- store starting position ...
  435.     cStartFile = alias()
  436.     select &cFile
  437.     
  438.     *-- look for a matching expression
  439.     seek cSeekExp
  440.     if found()
  441.         cRetVal = &cReturn
  442.     else
  443.         cRetVal = "<Not Found>"
  444.     endif
  445.     
  446.     *-- Store current color and draw a box
  447.     cAttr = set("ATTRIBUTES")
  448.     @nULRow+1,nULCol+1 fill to nBRRow+1,nBRCol+1 color w/n  && shadow
  449.     set color to &cColor
  450.     @nULRow,nULCol clear to nBRRow,nBRCol  && clear out area text will go in
  451.     @nULRow,nULCol To       nBRRow,nBRCol  && draw box
  452.     
  453.     *-- display matching expresion, and return to initial area ...
  454.     @nULRow+1,nULCol+2 say cRetVal
  455.     do ReColor with cAttr
  456.     select cStartFile
  457.     
  458. RETURN .t.
  459. *-- EoF: SeeMatch()
  460.  
  461. FUNCTION Dialog
  462. *-------------------------------------------------------------------------------
  463. *-- Programmer..: Larry Quaglia (Borland)
  464. *-- Date........: 11/xx/1991
  465. *-- Notes.......: This routine provides a 'standard' set of dialogue boxes
  466. *--               and buttons for all applications. The concept is to provide
  467. *--               standardization for your apps. Taken from TECHNOTES.
  468. *-- Written for.: dBASE IV, 1.1
  469. *-- Rev. History: 11/xx/1991 -- first published in TechNotes.
  470. *--               06/09/1992 -- Modified to handle explicit colors, changed
  471. *--               the color parameters a tad ... (Ken Mayer)
  472. *-- Calls.......: SHADOW               Function in PROC.PRG
  473. *--               RECOLOR              Procedure in PROC.PRG
  474. *-- Called by...: Any
  475. *-- Usage.......: Dialog("<cMsg>",<nType>,"<cBorder>",<nDefBut>,<lShadow>,;
  476. *--                      "<cWind>","<cButton>")
  477. *-- Example.....: Dialog("We have completed the transaction.",0,"DOUBLE",;
  478. *--                      0,.t.,"RG+/GB","W+/N")
  479. *-- Returns.....: Character -- Either 'ERROR' or title of Button.
  480. *-- Parameters..: cMsg    = Message to be displayed -- maximum of 78 characters
  481. *--                          (one line only)
  482. *--               nType   = Dialogue box TYPE. Options are 0 to 5:
  483. *--                         0:   'OK'
  484. *--                         1: 'OK'  'CANCEL'
  485. *--                         2: 'ABORT'  'RETRY'  'IGNORE'
  486. *--                         3: 'YES'  'NO'  'CANCEL'
  487. *--                         4: 'YES'  'NO'
  488. *--                         5: 'RETRY' 'CANCEL'
  489. *--               cBorder = Border Style -- options are: "" (null) for SINGLE
  490. *--                         DOUBLE or PANEL.
  491. *--               nDefBut = Default Button. 
  492. *--               lShadow = Display with a shadow or not (both on window and
  493. *--                         buttons)?
  494. *--               cWind   = Window Colors (must be valid dBASE color combo:
  495. *--                          i.e., "RG+/GB")
  496. *--               cButton = Highlighted Button Color (Same as above, should 
  497. *--                         contrast ...)
  498. *-------------------------------------------------------------------------------
  499.  
  500.     parameters cMsg,nType,cBorder,nDefBut,lShadow,cWind,cButton
  501.     private nMsgLen,cNewColor,aButton,nMaxLine,nY,nBoxLen,nNumButton,nCounter,;
  502.             nBasex,nYCol,nMsgLoc,cCurColor
  503.  
  504.     save screen to sDialog              && so we can restore at end of routine
  505.     
  506.     *-- determine length of message
  507.     nMsgLen = len(trim(ltrim(cMsg))) + 1
  508.     
  509.     *-- Check for valid parms
  510.     do case
  511.         case nMsgLen > 78
  512.             RETURN "ERROR - Message Length"
  513.         case .not. (upper(cBorder) = "DOUBLE" .or. upper(cBorder) = "PANEL" .or.;
  514.                     len(trim(cBorder)) = 0)
  515.             RETURN "ERROR - Border"
  516.     endcase
  517.     
  518.     *-- save current color info and set color to user-defined
  519.     cCurColor = set("ATTRIBUTES")
  520.     set color of normal    to &cWind
  521.     set color of box       to &cWind
  522.     set color of message   to &cWind
  523.     set color of highlight to &cButton
  524.     
  525.     *-- Allow use of <Tab> to move from button to button
  526.     on key label tab keyboard chr(4)  && act as if right arrow were pushed
  527.     
  528.     *-- Define button array -- max of 3 buttons (at the moment)
  529.     declare aButton[3]
  530.     aButton[1] = ""
  531.     aButton[2] = ""
  532.     aButton[3] = ""
  533.     
  534.     *-- Establish screen height to properly center dialogue box
  535.     nMaxLine = iif(right(set("DISP"),2) = "43",43,24)
  536.     
  537.     *-- Determine length of passed "message" parameter. If long enough, make
  538.     *-- the dialog box a little bigger. If very short, make it just big
  539.     *-- enough to accomodate the three buttons.
  540.     nY = iif(int(nMsgLen) > 30,int(nMsgLen/2)+2,24)
  541.     nBoxLen = 2 * nY
  542.     
  543.     *-- Setup the window and determine if shadow ... if yes, call shadow
  544.     define window wDialog from int(nMaxLine/2)-5,40-nY to ;
  545.         int(nMaxLine/2)+4,40+nY &cBorder 
  546.     if lShadow
  547.         activate screen
  548.         do shadow with int(nMaxLine/2)-5,40-nY,int(nMaxLine/2)+4,40+nY
  549.     endif
  550.     activate window wDialog
  551.     clear
  552.     
  553.     *-- Determine the type of buttons and set appropriate parms.
  554.     *-- These could be modified to your own needs.
  555.     do case
  556.         case nType = 0
  557.             nNumButton = 1
  558.             aButton[1] = "   OK   "
  559.         case nType = 1
  560.             nNumButton = 2
  561.             aButton[1] = "   OK   "
  562.             aButton[2] = " CANCEL "
  563.         case nType = 2
  564.             nNumButton = 3
  565.             aButton[1] = " ABORT  "
  566.             aButton[2] = " RETRY  "
  567.             aButton[3] = " IGNORE "
  568.         case nType = 3
  569.             nNumButton = 3
  570.             aButton[1] = "   YES  "
  571.             aButton[2] = "   NO   "
  572.             aButton[3] = " CANCEL "
  573.         case nType = 4
  574.             nNumButton = 2
  575.             aButton[1] = "   YES  "
  576.             aButton[2] = "   NO   "
  577.         case nType = 5
  578.             nNumButton = 2
  579.             aButton[1] = " RETRY  "
  580.             aButton[2] = " CANCEL "
  581.     endcase
  582.     
  583.     *-- Get dialog box length to create a bar menu of appropriate size.
  584.     *-- Define the bar menu in a loop. Deactivate it upon selection of
  585.     *-- one of the buttons.
  586.     nCounter = 1
  587.     nBaseX = nBoxLen / (nNumButton + 1)
  588.     define menu mDialog
  589.     do while nCounter <= nNumButton
  590.         pPadName = "PAD"+str(nCounter,1)  && pad name is 'PAD #'
  591.         nYCol = (nCounter * nBaseX) - (int(len(aButton[nCounter]) /2))
  592.         define pad &pPadName of mDialog prompt aButton[nCounter] at 4,nYCol
  593.         
  594.         *-- If shadow is on, put shadows on buttons as well ...
  595.         if lShadow
  596.             activate screen
  597.             do shadow with 3,nYCol-2,5,nYCol+(len(aButton[nCounter]))-1
  598.         endif
  599.         @3,nYCol-1 to 5,nYCol+(len(aButton[nCounter]))  && box around button
  600.         on selection pad &pPadName of mDialog deactivate menu
  601.         nCounter = nCounter + 1
  602.     enddo
  603.     
  604.     *-- place message (centered in box)
  605.     nMsgLoc = int(nBoxLen/2) - int(nMsgLen/2)
  606.     @1,nMsgLoc say cMsg
  607.     
  608.     *-- place cursor to the default button specified by the user
  609.     nCounter = 1
  610.     do while nCounter < nDefBut
  611.         keyboard chr(4)
  612.         nCounter = nCounter + 1
  613.     enddo
  614.     
  615.     *-- Activate the whole thing, and return the button name
  616.     activate menu mDialog
  617.     cValue = trim(ltrim(prompt()))
  618.     
  619.     *-- deactivate it all, restore screen, etc.
  620.     deactivate window wDialog
  621.     release window wDialog
  622.     release menu mDialog
  623.     restore screen from sDialog
  624.     release screen sDialog
  625.     do ReColor with cCurColor
  626.     on key label tab
  627.     
  628. RETURN cValue
  629. *-- EoF: Dialog()
  630.  
  631. FUNCTION MsgExp
  632. *-------------------------------------------------------------------------------
  633. *-- Programmer..: Adam Menkes (Borland)
  634. *-- Date........: 02/05/1993
  635. *-- Notes.......: Allows you to display message (or error message), centered
  636. *--               like SET MESSAGE ... with added utility. Does not use
  637. *--               "(Press Space)", which can be annoying. The message and the
  638. *--               line on which it is displayed will be the same color.
  639. *--               Taken from TECHNOTES.
  640. *-- Written for.: dBASE IV, 1.1
  641. *-- Rev. History: 09/xx/1991 -- Original routine
  642. *--               02/05/1993 -- Modified by Lee Hite to handle a string that
  643. *--                             is greater than 80 characters (this can be
  644. *--                             a real problem if the message is in row 24!)
  645. *-- Usage.......: MsgExp("<cExp>")
  646. *-- Example.....: MsgExp("This is a message")
  647. *-- Returns.....: Message displayed (centered) on screen
  648. *-- Parameters..: cExp  = Message to be displayed
  649. *-------------------------------------------------------------------------------
  650.  
  651.     parameters cMsg
  652.     private nLen
  653.     
  654.     nLen = (80-len(trim(cMsg)))/2
  655.  
  656. RETURN space(nLen) + trim(cMsg) + space(nLen+0.5)
  657. *-- EoF: MsgExp
  658.  
  659. FUNCTION YesNoCan
  660. *-------------------------------------------------------------------------------
  661. *-- Programmer..: Miriam Liskin
  662. *-- Date........: 02/01/1993
  663. *-- Notes.......: Asks a yes/no/cancel question in a dialog window/box
  664. *-- Written for.: dBASE IV, 1.1
  665. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  666. *--               04/29/1991 - Modified to Ken Mayer add shadow
  667. *--               05/13/1991 - Modified to Ken Mayer remove need for extra 
  668. *--                            procedures (YES/NO) that were used for returning
  669. *--                            values from Menu
  670. *--                            (suggested by Clinton L. Warren (VBCES))
  671. *--               01/20/1992 - Modified by Martin Leon (HMan) to handle user
  672. *--                            pressing 'Y' or 'N' keys (with ON KEY ...).
  673. *--               06/11/1992 - Modified by Joey Carroll (JOEY) to allow
  674. *--                            answer choices to be "Yes", "No", or "Cancel"
  675. *--                            or to allow for parameters to pass the contents
  676. *--                            of the prompts. If none are passed, they default
  677. *--                            to "Yes", "No", "Cancel". Further modified to
  678. *--                            allow specification of location by row if 
  679. *--                            desired. Window size now varies as parameters 
  680. *--                            dictate.
  681. *--               09/21/1992 - Modified by JOEY to fix bug caused if leading
  682. *--                            blanks in parameters cPrompt1,cPrompt2,cPrompt3
  683. *--                            Corrected example - case pad()="PPAD1"
  684. *--                            instead of          case pad()=PPAD1
  685. *--               02/01/1993 - Mods by Lee Hite: Routine would not wait for
  686. *--                            user response if "default" answer did not match
  687. *--                            one of the prompts. Now first prompt becomes
  688. *--                            default if no match is found on invocation.
  689. *--                            Also, match is no longer case sensitive.  Also
  690. *--                            made window height variable if message
  691. *--                            lines 2 and/or 3 are null strings.  Finally,
  692. *--                            added "confirmation" parameter which when set
  693. *--                            true will force user to press [Enter] before
  694. *--                            function returns.
  695. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  696. *--               CENTER               Procedure in PROC.PRG
  697. *--               ISBLANK()            Function in MISC.PRG, Internal in 1.5
  698. *-- Called by...: Any
  699. *-- Usage.......: YesNoCan("<cAnswer>","<cMess1>","<cMess2>","<cMess3>",;
  700. *--                 "<cPrompt1>","<cPrompt2>","<cPrompt3>",;
  701. *--                  <nTopRow>,"<cColor>",[lConfirm])
  702. *-- Example.....: cAnswer="Y"
  703. *--               cAnswer=YesNoCan(cAnswer,"*** Warning ***",;
  704. *--                            "A serious error has occured.",;
  705. *--                             "Choose carefully.","Proceed",;
  706. *--                             "Retry","Cancel",10,;
  707. *--                             "w+/r,n/w,w+/r")
  708. *--               do case
  709. *--                  case cAnswer="Y"    && OR case pad()="PPAD1"
  710. *--                     * do your thing
  711. *--                  case cAnswer="N"    && OR case pad()="PPAD2"
  712. *--                     skip
  713. *--                  case cAnswer="C"    && OR case pad()="PPAD3"
  714. *--                     * e.g. - return
  715. *--               endcase
  716. *--
  717. *--                 The middle set of colors should be different, as they
  718. *--                 will be the colors of the YES/NO selections ...
  719. *--                 Options may be blank by using nul values ("")
  720. *-- Returns.....: First character of selected pad
  721. *-- Parameters..: cAnswer  =  default value (Yes or No or Cancel) for menu
  722. *--               cMess1   =  First line of Message
  723. *--               cMess2   =  Second line of message
  724. *--               cMess3   =  Third line of message
  725. *--               cPrompt1 =  Optional prompt for left pad
  726. *--               cPrompt2 =  Optional prompt for middle pad
  727. *--               cPrompt3 =  Optional prompt for right pad
  728. *--               nTopRow  =  Optional top row of window
  729. *--               cColor   =  Optional colors for window/menu/box
  730. *--               lConfirm =  Optional "confirmation" parameter -- if true
  731. *--                           user must press [Enter], otherwise pressing
  732. *--                           a valid prompt key automatically returns
  733. *-------------------------------------------------------------------------------
  734.  
  735.    parameter cAnswer,cMess1,cMess2,cMess3,;
  736.       cPrompt1,cPrompt2,cPrompt3,nTopRow,cColor,lConfirm
  737.    private nLMargin,nRMargin,lWrap,nTopRowMax,cKey1,cKey2,cKey3,nWinWidth, ;
  738.       cConfirm, nWinHgth, nMsgRow
  739.     private cPrompt1,cPrompt2,cPrompt3 
  740.     
  741.     *-- save screen so we can restore ...
  742.    save screen to sYesNoCan
  743.    * locate top row of window
  744.    nTopRowMax = iif(set("STATUS") = "OFF",17,14) && protect Status Line
  745.    nTopRow = iif(isblank(nTopRow),14,nTopRow) && no parameter passed
  746.    nTopRow = min(nTopRowMax,nTopRow)
  747.  
  748.    * set pad prompts if none passed
  749.    cPrompt1 = iif(isblank(cPrompt1),"Yes",cPrompt1)
  750.    cPrompt2 = iif(isblank(cPrompt2),"No",cPrompt2)
  751.    cPrompt3 = iif(isblank(cPrompt3),"Cancel",cPrompt3)
  752.    cAnswer = iif(isblank(cAnswer),cPrompt1,cAnswer)
  753.  
  754.    * program bombs if prompts passed contain leading blanks
  755.    cPrompt1 = ltrim(trim(cPrompt1))
  756.    cPrompt2 = ltrim(trim(cPrompt2))
  757.    cPrompt3 = ltrim(trim(cPrompt3))
  758.  
  759.    * determine how wide the window needs to be
  760.    nWinWidth = max(19,len(cPrompt1 + cPrompt2 + cPrompt3) +13)
  761.    nWinWidth = max(nWinWidth,len(cMess1)+4)
  762.    nWinWidth = max(nWinWidth,len(cMess2)+4)
  763.    nWinWidth = max(nWinWidth,len(cMess3)+4)
  764.    * and how high it needs to be
  765.    nWinHgth = iif(""=cMess2,7,8)
  766.    nWinHgth = iif(""=cMess3,nWinHgth-1,nWinHgth)
  767.    * and center it
  768.    define window wYesNoCan from nTopRow,40-(nWinWidth+2)/2 ;
  769.       to nTopRow+nWinHgth-1,40+(nWinWidth+2)/2 double color &cColor.
  770.    define menu mYesNoCan
  771.    define pad pPad1 of mYesNoCan Prompt "["+cPrompt1+"]" ;
  772.       at nWinHgth-3,02
  773.    * center middle prompt between other two, not center of window
  774.    define pad pPad2 of mYesNoCan Prompt "["+cPrompt2+"]" at nWinHgth-3, ;
  775.       ((nWinWidth-len(cPrompt2))/2+(len(cPrompt1)-len(cPrompt3))/2)
  776.    define pad pPad3 of mYesNoCan Prompt "["+cPrompt3+"]"  ;
  777.       at nWinHgth-3,(nWinWidth-3)-(len(cPrompt3))
  778.    on selection pad pPad1 of mYesNoCan deactivate menu
  779.    on selection pad pPad2 of mYesNoCan deactivate menu
  780.    on selection pad pPad3 of mYesNoCan deactivate menu
  781.     
  782.    activate screen
  783.    do shadow with nTopRow,40-(nWinWidth+2)/2,nTopRow+nWinHgth-1, ;
  784.       40+(nWinWidth+2)/2
  785.    activate window wYesNoCan
  786.     
  787.    do center with 0,nWinWidth,"",cMess1       && center the text
  788.    *-- deal with blank message lines
  789.    nMsgRow = 2
  790.    if "" <> cMess2
  791.       do center with nMsgRow,nWinWidth,"",cMess2
  792.       nMsgRow = nMsgRow + 1
  793.    endif
  794.    if "" <> cMess3
  795.       do center with nMsgRow,nWinWidth,"",cMess3
  796.    endif
  797.    *-- deal with user pressing first key of prompt
  798.    cKey1 = left(cPrompt1,1)
  799.    cKey2 = left(cPrompt2,1)
  800.    cKey3 = left(cPrompt3,1)
  801.  
  802.    *-- set [CR] at end of keyboard command depending on "confirm" parameter
  803.    cConfirm = iif(lConfirm,"",chr(13))
  804.  
  805.    on key label &cKey1. keyboard iif( PAD() = "PPAD1", "", ;
  806.       iif(pad() = "PPAD2", chr(19),CHR(4) )) + cConfirm
  807.    on key label &cKey2. keyboard iif( PAD() = "PPAD2",  "", ;
  808.       iif(pad() = "PPAD1",CHR(4),chr(19) )) + cConfirm
  809.    on key label &cKey3. keyboard iif( PAD() = "PPAD3", "", ;
  810.       iif(pad() = "PPAD2", CHR(4),chr(19))) + cConfirm
  811.    clear typeahead
  812.     *-- otherwise deal with regular "menu" abilities
  813.    do case
  814.       case upper(cAnswer)=upper(cKey1)
  815.            activate menu mYesNoCan pad pPad1
  816.       case upper(cAnswer)=upper(cKey2)
  817.            activate menu mYesNoCan pad pPad2
  818.       case upper(cAnswer)=upper(cKey3)
  819.            activate menu mYesNoCan pad pPad3
  820.       otherwise
  821.            activate menu mYesNoCan pad pPad1
  822.    endcase
  823.     
  824.     *-- clear out ON KEY settings ...
  825.    on key label &cKey1.
  826.    on key label &cKey2.
  827.    on key label &cKey3.
  828.     *-- reset environment
  829.    deactivate window wYesNoCan
  830.    release window wYesNoCan
  831.    restore screen from sYesNoCan
  832.    release screen sYesNoCan
  833.    release menu mYesNoCan
  834.  
  835. RETURN upper(substr(prompt(),2,1))
  836. *-- EoF: YesNoCan()
  837.  
  838. PROCEDURE ProgBar2
  839. *-------------------------------------------------------------------------------
  840. *-- Programmer..: Joey D. Carroll (JOEY)
  841. *-- Date........: 06/28/1992
  842. *-- Notes.......: A crippled version of PROGBAR for those who want it simple.
  843. *--               A visual indicator of program activity, i.e. shows
  844. *--               user program didn't die during long processes which
  845. *--               do not normally show 'on screen'.  Serves same purpose
  846. *--               as MONITOR, but is more graphic.
  847. *--               For best appearance, set cursor 'off' from calling
  848. *--               program, outside of the loop which calls PROGBAR.
  849. *-- Written for.: dBASE IV, 1.5
  850. *-- Rev. History: 10/26/1992 -- protected existing active window.
  851. *-- Calls.......: None
  852. *-- Called by...: Any
  853. *-- Usage.......: do PROGBAR2 with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2>
  854. *-- Example.....: *-- determine what process will be monitored and what the
  855. *--               *-- final value will be, e.g. nReccount = reccount()
  856. *--               use <anyfile>
  857. *--               nReccount = reccount()
  858. *--               set cursor off
  859. *--               scan
  860. *--                  do progbar2 with nReccount,",,w+/n","w+/r","w+/g"
  861. *--                  *-- do some needed process here
  862. *--               endscan
  863. *--               *-- cleanup
  864. *-- Returns.....: None
  865. *-- Parameters..: nQuan     = maximum number of iterations
  866. *--               cWindCol  = the window colors
  867. *--               cFillCol1 = color of ruler before process
  868. *--               cFillCol2 = color of ruler after process
  869. *-------------------------------------------------------------------------------
  870.  
  871.    parameters nQuan,cWindCol,cFillCol1,cFillCol2   && e.g. how many records
  872.    private nWindWidth
  873.    nWindWidth = 78  && hard coded, wall to wall
  874.  
  875.    *-- skip this section if we've been here before
  876.    *-- this procedure called from inside a loop
  877.    *-- following section ignored except on first iteration thru loop
  878.    if type("nTimes") = "U"
  879.       save screen to sProgBar
  880.       public nFactor,nTimes,wPrevWind
  881.         wPrevWind = window()
  882.       if set("status") = "ON"  && different location if status "on"
  883.          define window wProgBar from 19,0 to 21,79 double color &cWindCol
  884.       else
  885.          define window wProgBar from 21,0 to 23,79 double color &cWindCol
  886.       endif   && set("status") = "ON"
  887.       activate window wProgBar
  888.       @ 0,0 say replicate(".",nWindWidth - 1)  && the ruler
  889.       @ 0,0 say "0%"                        && and some gradation %'s
  890.       @ 0,nWindWidth / 4 - 2 say "25%"
  891.       @ 0,nWindWidth / 2 - 2 say "50%"
  892.       @ 0,3*(nWindWidth / 4) - 2 say "75%"
  893.       @ 0,nWindWidth - 4 say "100%"
  894.       @ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1  && color of ruler before process
  895.       nFactor = nQuan/nWindWidth   && e.g. how many records per bar part(cols)
  896.       nTimes = 0  && times thru loop
  897.    endif      && type("nTimes") = "U"
  898.  
  899.    *-- the section will be processed as many times as required by nQuan
  900.    nTimes = nTimes+1
  901.    @ 0,0 fill to 0,int(nTimes/nFactor) ;
  902.          - iif(int(nTimes/nFactor) -1 >= 0,1,0) ;
  903.          color &cFillCol2    && color of ruler as processing takes place
  904.  
  905.    if nTimes = nQuan  && we done
  906.       x = inkey(.5)   && leave on screen just a liitle while after completion
  907.       * cleanup your mess
  908.       deactivate window wProgBar
  909.       release window wProgBar
  910.       restore screen from sProgBar
  911.       release screen sProgBar
  912.         *-- if window was active, re-activate
  913.         if .not. isblank(wPrevWind)
  914.             activate window wPrevWind
  915.         endif
  916.       release nProgBar,nFactor,nTimes,nWindWidth,x,wPrevWind
  917.    endif
  918.  
  919. RETURN
  920. *-- EoP: PROGBAR2
  921.  
  922. PROCEDURE MovePad
  923. *-------------------------------------------------------------------------------
  924. *-- Programmer..: Angus Scott-Fleming (CIS: 65500,3223)
  925. *-- Date........: 07/24/1992
  926. *-- Notes.......: Used to move the selected pad in a dBASE Bar Menu if the user
  927. *--               selects the first letter/key of the pad. The routine doesn't
  928. *--               re-evalute PAD(), and is based on Genifer code (improved on
  929. *--               by Angus). This should be used with the ON KEY command.
  930. *--               NOTE: This routine assumes you are using the dUFLP/dHUNG
  931. *--               standard for naming pads, and that the first character of
  932. *--               each pad NAME is 'p' (i.e., pColor, pExit, etc.).
  933. *-- Written for.: dBASE IV, 1.5, should work in 1.1.
  934. *-- Rev. History: 07/29/1992 -- Added header/notes.
  935. *-- Calls.......: None
  936. *-- Called by...: Any
  937. *-- Usage.......: do MovePad with <cLetter>,<lSelect>,<cChoices>
  938. *-- Example.....: on key label "C" do MovePad with "C",.t.,cChoices
  939. *-- Returns.....: None
  940. *-- Parameters..: cLetter  = first letter/key on pad
  941. *--               lSelect  = select pad, or move cursor to it? (Act as if user
  942. *--                          pressed <Enter> after moving to it?)
  943. *--               cChoices = list of possible choices (i.e., 
  944. *--                                 "Enter,Edit,Delete,Print,Exit")
  945. *-------------------------------------------------------------------------------
  946.  
  947.    parameters cLetter, lSelect, cChoices
  948.    private nToMove
  949.  
  950.    *-- determine how many pads to move, based on position of choice in list
  951.    *-- of choices (cChoices).
  952.    nToMove = at(cLetter,cChoices) - at(substr(pad(),2,1),cChoices)
  953.  
  954.    *-- if it is a negative value, move to the left, and press <Enter> if 
  955.    *-- lSelect = .t. (otherwise, just move there and stop).
  956.    if nToMove < 0
  957.         keyboard replicate(chr(5), -nToMove) + iif(lSelect,chr(13),"")
  958.     else
  959.         keyboard replicate(chr(24), nToMove) + iif(lSelect,chr(13),"")
  960.     endif
  961.  
  962. RETURN
  963. *-- EoP: MovePad
  964.  
  965. PROCEDURE Monitor
  966. *-------------------------------------------------------------------------------
  967. *-- Programmer..: Miriam Liskin
  968. *-- Date........: 06/08/1992
  969. *-- Notes.......: Displays a status message to monitor a long-running 
  970. *--                 operation that operates on multiple records . . . 
  971. *--                 Should be used with MONITOROFF (below) to cleanup.
  972. *-- Written for.: dBASE IV, 1.1
  973. *-- Rev. History: 04/29/1991 - Modified by Ken Mayer to add shadow
  974. *--               06/08/1992 - Modified to handle explicit color setting
  975. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  976. *--               CENTER               Procedure in PROC.PRG
  977. *-- Called by...: Any
  978. *-- Usage.......: do monitor with "<cText>","<cColor>"
  979. *-- Example.....: do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb"
  980. *--               nRec = 0
  981. *--               do while  && (or SCAN)
  982. *--                  && stuff -- process records
  983. *--                  nRec = nRec + 1
  984. *--                  @4,30 display ltrim(str(nRec)) && current record
  985. *--                                                 && in window MONITOR
  986. *--               enddo  && (or endscan)
  987. *--               do MonitorOff  && procedure to clean-up after this one
  988. *-- Returns.....: None
  989. *-- Parameters..: cText  = Text to display
  990. *--               cColor = Colors for window
  991. *-------------------------------------------------------------------------------
  992.  
  993.     parameters cText,cColor
  994.     private cTempCol
  995.     
  996.     save screen to sMonitor
  997.     activate screen
  998.     define window wMonitor From 10,10 to 18,70 double color &cColor
  999.     do shadow with 10,10,18,70
  1000.     activate window wMonitor
  1001.     
  1002.     do center with 1,60,"",cText
  1003.     do center with 2,60,"","Please do not interrupt"
  1004.     @4,10 say "Working on record          of " + ltrim(str(reccount(),5))
  1005.     
  1006. RETURN
  1007. *-- EoP: Monitor
  1008.  
  1009. PROCEDURE MonitorOff
  1010. *-------------------------------------------------------------------------------
  1011. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1012. *-- Date........: 05/23/1991
  1013. *-- Notes.......: Used to deal with ending routines for MONITOR
  1014. *--                 procedure above.
  1015. *-- Written for.: dBASE IV, 1.1
  1016. *-- Rev. History: None
  1017. *-- Calls.......: None
  1018. *-- Called by...: Routine using MONITOR  Procedure in PROC.PRG
  1019. *-- Usage.......: do monitoroff
  1020. *-- Example.....: do monitoroff
  1021. *-- Returns.....: None
  1022. *-- Parameters..: None
  1023. *-------------------------------------------------------------------------------
  1024.  
  1025.     deactivate window wMonitor
  1026.     release window wMonitor
  1027.     restore screen from sMonitor
  1028.     release screen sMonitor
  1029.     
  1030. RETURN
  1031. *-- EoP: MonitorOff
  1032.  
  1033. FUNCTION NewBorder
  1034. *-------------------------------------------------------------------------------
  1035. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  1036. *-- Date........: 01/20/1993
  1037. *-- Notes.......: Will save current border setting (the returned value),
  1038. *--               and set a new one with one of a set of pre-defined
  1039. *--               borders. This will create a new variable if it doesn't
  1040. *--               already exist, called: c_Border, which is a PUBLIC Character
  1041. *--               variable. The purpose is so that you can keep using this
  1042. *--               string for other purpose (i.e., DEFINE WINDOW and such ...)
  1043. *-- Written for.: dBASE IV, 1.5
  1044. *-- Rev. History: None
  1045. *-- Calls.......: None
  1046. *-- Called by...: Any
  1047. *-- Usage.......: NewBorder("<cStyle>")
  1048. *-- Example.....: cOldBorder = NewBorder("K")
  1049. *--               @5,10 to 15,60  && draw box with new "border" setting
  1050. *--               *-- define a window with new "border" setting
  1051. *--               define window wTest from 10,20 to 20,60 &c_Border
  1052. *--               set border to &cOldBorder  && reset border to original
  1053. *-- Returns.....: Current border setting (before calling routine)
  1054. *-- Parameters..: cStyle = Style from one of the following:
  1055. *--                        A = Double
  1056. *--                                     ╔════╗
  1057. *--                                     ║    ║
  1058. *--                                     ╚════╝
  1059. *--                        B = Single
  1060. *--                                     ┌────┐
  1061. *--                                     │    │
  1062. *--                                     └────┘
  1063. *--                        C = Panel
  1064. *--                                     ██████
  1065. *--                                     █    █
  1066. *--                                     ██████
  1067. *--                        D = None
  1068. *--                        E = Double Top, Single Left, Right, and Bottom
  1069. *--                                      ╒════╕
  1070. *--                                      │    │
  1071. *--                                      └────┘
  1072. *--                        F = Single Top, Double Left, Right and Bottom
  1073. *--                                      ╓────╖
  1074. *--                                      ║    ║
  1075. *--                                      ╚════╝
  1076. *--                        G = Double Top, Left, Right, Single Bottom
  1077. *--                                      ╔════╗
  1078. *--                                      ║    ║
  1079. *--                                      ╙────╜
  1080. *--                        H = Single Top, Left, Right, Double Bottom
  1081. *--                                      ┌────┐
  1082. *--                                      │    │
  1083. *--                                      ╘════╛
  1084. *--                        I = Double Top, Single Left and Right, Double Bottom
  1085. *--                                      ╒════╕
  1086. *--                                      │    │
  1087. *--                                      ╘════╛
  1088. *--                        J = Single Top, Double Left and Right, Single Bottom
  1089. *--                                      ╓────╖
  1090. *--                                      ║    ║
  1091. *--                                      ╙────╜
  1092. *--                        K = Single Top and Left, Double Right and Bottom
  1093. *--                                      ┌────╖
  1094. *--                                      │    ║
  1095. *--                                      ╘════╝
  1096. *--                        L = Single Top, Double Left, Single Right, Dbl Bottom
  1097. *--                                      ╓────┐
  1098. *--                                      ║    │
  1099. *--                                      ╚════╛
  1100. *--                        M = Double Top and Left, Single Right and Bottom
  1101. *--                                      ╔════╕
  1102. *--                                      ║    │
  1103. *--                                      ╙────┘
  1104. *--                        N = Double Top, Single Left, Double Right, Sgl Bottom
  1105. *--                                      ╒════╗
  1106. *--                                      │    ║
  1107. *--                                      └────╜
  1108. *--                        O = Double Top, Single Left, Double Right and Bottom
  1109. *--                                      ╒════╗
  1110. *--                                      │    ║
  1111. *--                                      ╘════╝
  1112. *--                        P = Double Top, Left, Single Right, Double Bottom
  1113. *--                                      ╔═════╕
  1114. *--                                      ║     │
  1115. *--                                      ╚═════╛
  1116. *--                        Q = Single Top, Double Left, Single Right and Bottom
  1117. *--                                      ╓─────┐
  1118. *--                                      ║     │
  1119. *--                                      ╙─────┘
  1120. *--                        R = Single Top and Left, Double Right, Single Bottom
  1121. *--                                      ┌─────╖
  1122. *--                                      │     ║
  1123. *--                                      └─────╜
  1124. *--                        S = Panel, but with more room on the interior ...
  1125. *--                            the default 'panel' mode for borders uses
  1126. *--                            ASCII 219 (alla way around), where this 
  1127. *--                            uses 220-223 ...
  1128. *--                                      ▐▀▀▀▀▀▌
  1129. *--                                      ▐     ▌
  1130. *--                                      ▐▄▄▄▄▄▌
  1131. *-------------------------------------------------------------------------------
  1132.  
  1133.     parameters cStyle
  1134.     cReturn = set("BORDER")    && current border -- if version of dBASE is
  1135.                                && less than 1.5, comment this out ...
  1136.     
  1137.     if type("c_Border") = "U"  && if this is undefined
  1138.         public c_Border         &&   declare it as public
  1139.     endif
  1140.     
  1141.     *-- here we go ...
  1142.     do case
  1143.         case cStyle = "A"   
  1144.             c_Border = "DOUBLE"   && pre-defined
  1145.         case cStyle = "B"
  1146.             c_Border = "SINGLE"   && pre-defined
  1147.         case cStyle = "C"
  1148.             c_Border = "PANEL"    && pre-defined
  1149.         case cStyle = "D"
  1150.             c_Border = "NONE"     && pre-defined
  1151.         case cStyle = "E"
  1152.             *-- items are: top line, bottom line, left line, right line,
  1153.             *-- upper left corner, upper right corner, bottom left corner,
  1154.             *-- bottom right corner
  1155.             c_Border = "205,196,179,179,213,184,192,217"
  1156.         case cStyle = "F"
  1157.             c_Border = "196,205,186,186,214,183,200,188"
  1158.         case cStyle = "G"
  1159.             c_Border = "205,196,186,186,201,187,211,189"
  1160.         case cStyle = "H"
  1161.             c_Border = "196,205,179,179,218,191,212,190"
  1162.         case cStyle = "I"
  1163.             c_Border = "205,205,179,179,213,184,212,190"
  1164.         case cStyle = "J"
  1165.             c_Border = "196,196,186,186,214,183,211,189"
  1166.         case cStyle = "K"
  1167.             c_Border = "196,205,179,186,218,183,212,188"
  1168.         case cStyle = "L"
  1169.             c_Border = "196,205,186,179,214,191,200,190"
  1170.         case cStyle = "M"
  1171.             c_Border = "205,196,186,179,201,184,211,217"
  1172.         case cStyle = "N"
  1173.             c_Border = "205,196,179,186,213,187,192,189"
  1174.         case cStyle = "O"
  1175.             c_Border = "205,205,179,186,213,187,212,188"
  1176.         case cStyle = "P"
  1177.             c_Border = "205,205,186,179,201,184,200,190"
  1178.         case cStyle = "Q"
  1179.             c_Border = "196,196,186,179,214,191,211,217"
  1180.         case cStyle = "R"
  1181.             c_Border = "196,196,179,186,218,183,192,189"
  1182.         case cStyle = "S"
  1183.             c_Border = "223,220,222,221,222,221,222,221"
  1184.     endcase
  1185.     
  1186.     set border to &c_Border
  1187.  
  1188. RETURN cReturn
  1189. *-- EoF: NewBorder
  1190.  
  1191. FUNCTION VidRow
  1192. *-------------------------------------------------------------------------------
  1193. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1194. *-- Date........: 01/28/1993
  1195. *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
  1196. *--               to return the ABSOLUTE position of the current ROW on the
  1197. *--               screen, despite any active windows, etc.
  1198. *--               This is based on original routines by David Frankenbach,
  1199. *--               but includes the load/release in one routine, rather
  1200. *--               than requiring three functions to perform this ...
  1201. *--               ***************************
  1202. *--               ** REQUIRES VDCURSOR.BIN **
  1203. *--               ***************************
  1204. *-- Written for.: dBASE IV, 1.5
  1205. *-- Rev. History: None
  1206. *-- Calls.......: VDCURSOR.BIN
  1207. *-- Called by...: Any 
  1208. *-- Usage.......: VidRow()
  1209. *-- Example.....: ?VidRow()
  1210. *-- Returns.....: Numeric ROW position for current row on screen
  1211. *-- Parameters..: None
  1212. *-------------------------------------------------------------------------------
  1213.  
  1214.     private cX
  1215.     
  1216.     cX = space(2)             && define argument memvar
  1217.     load vdcursor             && load the .BIN file
  1218.     call vdcursor with cX     && call it with the memvar
  1219.     release module vdcursor   && release from memory
  1220.  
  1221. RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position
  1222. *-- EoF: VidRow()
  1223.  
  1224. FUNCTION VidCol
  1225. *-------------------------------------------------------------------------------
  1226. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1227. *-- Date........: 01/28/1993
  1228. *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
  1229. *--               to return the ABSOLUTE position of the current COLUMN on the
  1230. *--               screen, despite any active windows, etc.
  1231. *--               This is based on original routines by David Frankenbach,
  1232. *--               but includes the load/release in one routine, rather
  1233. *--               than requiring three functions to perform this ...
  1234. *--               ***************************
  1235. *--               ** REQUIRES VDCURSOR.BIN **
  1236. *--               ***************************
  1237. *-- Written for.: dBASE IV, 1.5
  1238. *-- Rev. History: None
  1239. *-- Calls.......: VDCURSOR.BIN
  1240. *-- Called by...: Any 
  1241. *-- Usage.......: VidCol()
  1242. *-- Example.....: ?VidCol()
  1243. *-- Returns.....: Numeric COLUMN position for current Col on screen
  1244. *-- Parameters..: None
  1245. *-------------------------------------------------------------------------------
  1246.  
  1247.     private cX
  1248.     
  1249.     cX = space(2)             && define argument memvar
  1250.     load vdcursor             && load the .BIN file
  1251.     call vdcursor with cX     && call it with the memvar
  1252.     release module vdcursor   && release from memory
  1253.  
  1254. RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position
  1255. *-- EoF: VidCol()
  1256.  
  1257. FUNCTION PwdMask
  1258. *-------------------------------------------------------------------------------
  1259. *-- Programmer..: Kenneth J. Mayer
  1260. *-- Date........: 01/29/1993
  1261. *-- Notes.......: Designed to display a mask on the screen when a user is
  1262. *--               entering a password, rather than a blank surface. Should
  1263. *--               handle backspaces to delete ... ASSUMES <cField> is a
  1264. *--               memvar.
  1265. *--               ***************************
  1266. *--               ** REQUIRES VDCURSOR.BIN **
  1267. *--               ***************************
  1268. *-- Written for.: dBASE IV, 1.5
  1269. *-- Rev. History: None
  1270. *-- Calls.......: VidRow()             Function in SCREEN.PRG
  1271. *--               VidCol()             Function in SCREEN.PRG
  1272. *-- Called by...: Any
  1273. *-- Usage.......: PwdMask("<cField>"[,<nMaskChar>])
  1274. *-- Example.....: @5,10 get password when PwdMask("Password");
  1275. *--                      valid required .not. isblank(password);
  1276. *--                      error chr(7)+"Password cannot be blank)
  1277. *-- Returns.....: .T., and field will have password placed in it when done.
  1278. *-- Parameters..: cField    = name of the field
  1279. *--               nMaskChar = ASCII code for mask character. OPTIONAL parameter.
  1280. *--                           if not provided, will use asterisk. Suggested
  1281. *--                           characters include: 176,177,178,219,248,249,254
  1282. *--                                                ░   ▒   ▓   █   °   ∙   ■
  1283. *-------------------------------------------------------------------------------
  1284.  
  1285.     parameters cField, nMaskChar
  1286.     private nLength, nChar, nX
  1287.     
  1288.     *-- deal with mask character
  1289.     if type("NMASKCHAR") = "L"
  1290.         nMaskChar = 42               && *
  1291.     endif
  1292.     
  1293.     lCursor = set("CURSOR") = "ON"
  1294.     set cursor off             && rather than have the cursor in the way ...
  1295.     nLength = len(&cField.)    && get length of current field
  1296.     nChar = 0                  && input character
  1297.     nRow = vidrow()            && get absolute cursor location
  1298.     nCol = vidcol()            && ditto
  1299.     cTemp = ""                 && initialize temp memvar
  1300.     do while len(cTemp) < nLength .and. nChar # 13  
  1301.                                && loop until we hit end of field
  1302.                                && or user presses <Enter>
  1303.     
  1304.         nChar = inkey(0)        && wait for user to enter something
  1305.         
  1306.         do case  
  1307.                                       
  1308.             case nChar = 127                    && <BackSpace>
  1309.                 if isblank(cTemp)                && if empty, don't delete anything
  1310.                     ?? chr(7)                     && instead, BEEP
  1311.                 else
  1312.                     cTemp = left(cTemp,len(cTemp)-1)  && backup one
  1313.                 endif
  1314.                 
  1315.             case (nChar => 65 .and. nChar <= 90) .or.;
  1316.                  (nChar => 97 .and. nChar <= 122) && alphabetic input only
  1317.                 cTemp = cTemp + chr(nChar)         && add character
  1318.                 
  1319.             case nChar = 13                       && <Enter>
  1320.                 exit
  1321.                 
  1322.             otherwise
  1323.                 ?? chr(7)                          && otherwise, BEEP
  1324.                 loop
  1325.         endcase
  1326.         
  1327.         *-- create the current "mask", padding with spaces ...
  1328.         cMask = replicate(chr(nMaskChar),len(cTemp)) + space(nLength-len(cTemp))
  1329.         *-- display it in same color as the current "GET"
  1330.         @nRow,nCol get cMask
  1331.         clear gets
  1332.         *-- put password into current memvar
  1333.         store cTemp to &cField.
  1334.         
  1335.     enddo
  1336.     
  1337.     *-- turn cursor on if it was prior to this routine
  1338.     if lCursor
  1339.         set cursor on
  1340.     endif
  1341.     
  1342.     keyboard chr(13)   && send a final <Enter> to exit this GET
  1343.     
  1344. RETURN .T.
  1345. *-- EoF: PwdMask()
  1346.  
  1347. *-------------------------------------------------------------------------------
  1348. *-- EoP: SCREEN.PRG
  1349. *-------------------------------------------------------------------------------
  1350.